home *** CD-ROM | disk | FTP | other *** search
Text File | 1991-10-31 | 55.5 KB | 1,694 lines |
- Newsgroups: comp.sources.misc
- From: daveg@synaptics.com (David Gillespie)
- Subject: v24i073: gnucalc - GNU Emacs Calculator, v2.00, Part25/56
- Message-ID: <1991Oct31.072757.18242@sparky.imd.sterling.com>
- X-Md4-Signature: 5191220bb34440415fd008f4ae7bf5c5
- Date: Thu, 31 Oct 1991 07:27:57 GMT
- Approved: kent@sparky.imd.sterling.com
-
- Submitted-by: daveg@synaptics.com (David Gillespie)
- Posting-number: Volume 24, Issue 73
- Archive-name: gnucalc/part25
- Environment: Emacs
- Supersedes: gmcalc: Volume 13, Issue 27-45
-
- ---- Cut Here and unpack ----
- #!/bin/sh
- # do not concatenate these parts, unpack them in order with /bin/sh
- # file calc-rewr.el continued
- #
- if test ! -r _shar_seq_.tmp; then
- echo 'Please unpack part 1 first!'
- exit 1
- fi
- (read Scheck
- if test "$Scheck" != 25; then
- echo Please unpack part "$Scheck" next!
- exit 1
- else
- exit 0
- fi
- ) < _shar_seq_.tmp || exit 1
- if test ! -f _shar_wnt_.tmp; then
- echo 'x - still skipping calc-rewr.el'
- else
- echo 'x - continuing file calc-rewr.el'
- sed 's/^X//' << 'SHAR_EOF' >> 'calc-rewr.el' &&
- ;;; argument is stored in "reg"; otherwise (provided this is an `a r'
- ;;; and not a `g r' command) the selected part is stored in "reg".
- ;;;
- ;;; (cond expr)
- ;;; The "expr", with registers substituted, must simplify to
- ;;; a non-zero value.
- ;;;
- ;;; (let reg expr)
- ;;; Evaluate "expr" and store the result in "reg". Always succeeds.
- ;;;
- ;;; (done rhs remember)
- ;;; Rewrite the expression to "rhs", with register substituted.
- ;;; Normalize; if the result is different from the original
- ;;; expression, the match has succeeded. This is the last
- ;;; instruction of every program. If "remember" is non-nil,
- ;;; record the result of the match as a new literal rule.
- X
- X
- ;;; Pseudo-functions related to rewrites:
- ;;;
- ;;; In patterns: quote, plain, condition, opt, apply, cons, select
- ;;;
- ;;; In righthand sides: quote, plain, eval, evalsimp, evalextsimp,
- ;;; apply, cons, select
- ;;;
- ;;; In conditions: let + same as for righthand sides
- X
- ;;; Some optimizations that would be nice to have:
- ;;;
- ;;; * Merge registers with disjoint lifetimes.
- ;;; * Merge constant registers with equivalent values.
- ;;;
- ;;; * If an argument of a commutative op math-depends neither on the
- ;;; rest of the pattern nor on any of the conditions, then no backtracking
- ;;; should be done for that argument. (This won't apply to very many
- ;;; cases.)
- ;;;
- ;;; * If top functor is "select", and its argument is a unique function,
- ;;; add the rule to the lists for both "select" and that function.
- ;;; (Currently rules like this go on the "nil" list.)
- ;;; Same for "func-opt" functions. (Though not urgent for these.)
- ;;;
- ;;; * Shouldn't evaluate a "let" condition until the end, or until it
- ;;; would enable another condition to be evaluated.
- ;;;
- X
- ;;; Some additional features to add / things to think about:
- ;;;
- ;;; * Figure out what happens to "a +/- b" and "a +/- opt(b)".
- ;;;
- ;;; * Same for interval forms.
- ;;;
- ;;; * Have a name(v,pat) pattern which matches pat, and gives the
- ;;; whole match the name v. Beware of circular structures!
- ;;;
- X
- (defun math-compile-patterns (pats)
- X (if (and (eq (car-safe pats) 'var)
- X (calc-var-value (nth 2 pats)))
- X (let ((prop (get (nth 2 pats) 'math-pattern-cache)))
- X (or prop
- X (put (nth 2 pats) 'math-pattern-cache (setq prop (list nil))))
- X (or (eq (car prop) (symbol-value (nth 2 pats)))
- X (progn
- X (setcdr prop (math-compile-patterns
- X (symbol-value (nth 2 pats))))
- X (setcar prop (symbol-value (nth 2 pats)))))
- X (cdr prop))
- X (let ((math-rewrite-whole t))
- X (cdr (math-compile-rewrites (cons
- X 'vec
- X (mapcar (function (lambda (x)
- X (list 'vec x
- X '(var XXX XXX))))
- X (if (eq (car-safe pats) 'vec)
- X (cdr pats)
- X (list pats))))))))
- )
- (setq math-rewrite-whole nil)
- (setq math-make-import-list nil)
- X
- (defun math-compile-rewrites (rules &optional name)
- X (if (eq (car-safe rules) 'var)
- X (let ((prop (get (nth 2 rules) 'math-rewrite-cache))
- X (math-import-list nil)
- X (math-make-import-list t)
- X p)
- X (or (calc-var-value (nth 2 rules))
- X (error "Rules variable %s has no stored value" (nth 1 rules)))
- X (or prop
- X (put (nth 2 rules) 'math-rewrite-cache
- X (setq prop (list (list (cons (nth 2 rules) nil))))))
- X (setq p (car prop))
- X (while (and p (eq (symbol-value (car (car p))) (cdr (car p))))
- X (setq p (cdr p)))
- X (or (null p)
- X (progn
- X (message "Compiling rule set %s..." (nth 1 rules))
- X (setcdr prop (math-compile-rewrites
- X (symbol-value (nth 2 rules))
- X (nth 2 rules)))
- X (message "Compiling rule set %s...done" (nth 1 rules))
- X (setcar prop (cons (cons (nth 2 rules)
- X (symbol-value (nth 2 rules)))
- X math-import-list))))
- X (cdr prop))
- X (if (or (not (eq (car-safe rules) 'vec))
- X (and (memq (length rules) '(3 4))
- X (let ((p rules))
- X (while (and (setq p (cdr p))
- X (memq (car-safe (car p))
- X '(vec
- X calcFunc-assign
- X calcFunc-condition
- X calcFunc-import
- X calcFunc-phase
- X calcFunc-schedule
- X calcFunc-iterations))))
- X p)))
- X (setq rules (list rules))
- X (setq rules (cdr rules)))
- X (if (assq 'calcFunc-import rules)
- X (let ((pp (setq rules (copy-sequence rules)))
- X p part)
- X (while (setq p (car (cdr pp)))
- X (if (eq (car-safe p) 'calcFunc-import)
- X (progn
- X (setcdr pp (cdr (cdr pp)))
- X (or (and (eq (car-safe (nth 1 p)) 'var)
- X (setq part (calc-var-value (nth 2 (nth 1 p))))
- X (memq (car-safe part) '(vec
- X calcFunc-assign
- X calcFunc-condition)))
- X (error "Argument of import() must be a rules variable"))
- X (if math-make-import-list
- X (setq math-import-list
- X (cons (cons (nth 2 (nth 1 p))
- X (symbol-value (nth 2 (nth 1 p))))
- X math-import-list)))
- X (while (setq p (cdr (cdr p)))
- X (or (cdr p)
- X (error "import() must have odd number of arguments"))
- X (setq part (math-rwcomp-substitute part
- X (car p) (nth 1 p))))
- X (if (eq (car-safe part) 'vec)
- X (setq part (cdr part))
- X (setq part (list part)))
- X (setcdr pp (append part (cdr pp))))
- X (setq pp (cdr pp))))))
- X (let ((rule-set nil)
- X (all-heads nil)
- X (nil-rules nil)
- X (rule-count 0)
- X (math-schedule nil)
- X (math-iterations nil)
- X (math-phases nil)
- X (math-all-phases nil)
- X (math-remembering nil)
- X math-pattern math-rhs math-conds)
- X (while rules
- X (cond
- X ((and (eq (car-safe (car rules)) 'calcFunc-iterations)
- X (= (length (car rules)) 2))
- X (or (integerp (nth 1 (car rules)))
- X (equal (nth 1 (car rules)) '(var inf var-inf))
- X (equal (nth 1 (car rules)) '(neg (var inf var-inf)))
- X (error "Invalid argument for iterations(n)"))
- X (or math-iterations
- X (setq math-iterations (nth 1 (car rules)))))
- X ((eq (car-safe (car rules)) 'calcFunc-schedule)
- X (or math-schedule
- X (setq math-schedule (math-parse-schedule (cdr (car rules))))))
- X ((eq (car-safe (car rules)) 'calcFunc-phase)
- X (setq math-phases (cdr (car rules)))
- X (if (equal math-phases '((var all var-all)))
- X (setq math-phases nil))
- X (let ((p math-phases))
- X (while p
- X (or (integerp (car p))
- X (error "Phase numbers must be small integers"))
- X (or (memq (car p) math-all-phases)
- X (setq math-all-phases (cons (car p) math-all-phases)))
- X (setq p (cdr p)))))
- X ((or (and (eq (car-safe (car rules)) 'vec)
- X (cdr (cdr (car rules)))
- X (not (nthcdr 4 (car rules)))
- X (setq math-conds (nth 3 (car rules))
- X math-rhs (nth 2 (car rules))
- X math-pattern (nth 1 (car rules))))
- X (progn
- X (setq math-conds nil
- X math-pattern (car rules))
- X (while (and (eq (car-safe math-pattern) 'calcFunc-condition)
- X (= (length math-pattern) 3))
- X (let ((cond (nth 2 math-pattern)))
- X (setq math-conds (if math-conds
- X (list 'calcFunc-land math-conds cond)
- X cond)
- X math-pattern (nth 1 math-pattern))))
- X (and (eq (car-safe math-pattern) 'calcFunc-assign)
- X (= (length math-pattern) 3)
- X (setq math-rhs (nth 2 math-pattern)
- X math-pattern (nth 1 math-pattern)))))
- X (let* ((math-prog (list nil))
- X (math-prog-last math-prog)
- X (math-num-regs 1)
- X (math-regs (list (list nil 0 nil nil)))
- X (math-bound-vars nil)
- X (math-aliased-vars nil)
- X (math-copy-neg nil))
- X (setq math-conds (and math-conds (math-flatten-lands math-conds)))
- X (math-rwcomp-pattern math-pattern 0)
- X (while math-conds
- X (let ((expr (car math-conds)))
- X (setq math-conds (cdr math-conds))
- X (math-rwcomp-cond-instr expr)))
- X (math-rwcomp-instr 'done
- X (math-rwcomp-match-vars math-rhs)
- X math-remembering)
- X (setq math-prog (cdr math-prog))
- X (let* ((heads (math-rewrite-heads math-pattern))
- X (rule (list (vconcat
- X (nreverse
- X (mapcar (function (lambda (x) (nth 3 x)))
- X math-regs)))
- X math-prog
- X heads
- X math-phases))
- X (head (and (not (Math-primp math-pattern))
- X (not (and (eq (car (car math-prog)) 'try)
- X (nth 5 (car math-prog))))
- X (not (memq (car (car math-prog)) '(func-opt
- X apply
- X select
- X alt)))
- X (if (memq (car (car math-prog)) '(func
- X func-def))
- X (nth 2 (car math-prog))
- X (if (eq (car math-pattern) 'calcFunc-quote)
- X (car-safe (nth 1 math-pattern))
- X (car math-pattern))))))
- X (let (found)
- X (while heads
- X (if (setq found (assq (car heads) all-heads))
- X (setcdr found (1+ (cdr found)))
- X (setq all-heads (cons (cons (car heads) 1) all-heads)))
- X (setq heads (cdr heads))))
- X (if (eq head '-) (setq head '+))
- X (if (memq head '(calcFunc-cons calcFunc-rcons)) (setq head 'vec))
- X (if head
- X (progn
- X (nconc (or (assq head rule-set)
- X (car (setq rule-set (cons (cons head
- X (copy-sequence
- X nil-rules))
- X rule-set))))
- X (list rule))
- X (if (eq head '*)
- X (nconc (or (assq '/ rule-set)
- X (car (setq rule-set (cons (cons
- X '/
- X (copy-sequence
- X nil-rules))
- X rule-set))))
- X (list rule))))
- X (setq nil-rules (nconc nil-rules (list rule)))
- X (let ((ptr rule-set))
- X (while ptr
- X (nconc (car ptr) (list rule))
- X (setq ptr (cdr ptr))))))))
- X (t
- X (error "Rewrite rule set must be a vector of A := B rules")))
- X (setq rules (cdr rules)))
- X (if nil-rules
- X (setq rule-set (cons (cons nil nil-rules) rule-set)))
- X (setq all-heads (mapcar 'car
- X (sort all-heads (function
- X (lambda (x y)
- X (< (cdr x) (cdr y)))))))
- X (let ((set rule-set)
- X rule heads ptr)
- X (while set
- X (setq rule (cdr (car set)))
- X (while rule
- X (if (consp (setq heads (nth 2 (car rule))))
- X (progn
- X (setq heads (delq (car (car set)) heads)
- X ptr all-heads)
- X (while (and ptr (not (memq (car ptr) heads)))
- X (setq ptr (cdr ptr)))
- X (setcar (nthcdr 2 (car rule)) (car ptr))))
- X (setq rule (cdr rule)))
- X (setq set (cdr set))))
- X (let ((plus (assq '+ rule-set)))
- X (if plus
- X (setq rule-set (cons (cons '- (cdr plus)) rule-set))))
- X (cons (list 'schedule math-iterations name
- X (or math-schedule
- X (sort math-all-phases '<)
- X (list 1)))
- X rule-set)))
- )
- X
- (defun math-flatten-lands (expr)
- X (if (eq (car-safe expr) 'calcFunc-land)
- X (append (math-flatten-lands (nth 1 expr))
- X (math-flatten-lands (nth 2 expr)))
- X (list expr))
- )
- X
- (defun math-rewrite-heads (expr &optional more all)
- X (let ((heads more)
- X (skips (and (not all)
- X '(calcFunc-apply calcFunc-condition calcFunc-opt
- X calcFunc-por calcFunc-pnot)))
- X (blanks (and (not all)
- X '(calcFunc-quote calcFunc-plain calcFunc-select
- X calcFunc-cons calcFunc-rcons
- X calcFunc-pand))))
- X (or (Math-primp expr)
- X (math-rewrite-heads-rec expr))
- X heads)
- )
- X
- (defun math-rewrite-heads-rec (expr)
- X (or (memq (car expr) skips)
- X (progn
- X (or (memq (car expr) heads)
- X (memq (car expr) blanks)
- X (memq 'algebraic (get (car expr) 'math-rewrite-props))
- X (setq heads (cons (car expr) heads)))
- X (while (setq expr (cdr expr))
- X (or (Math-primp (car expr))
- X (math-rewrite-heads-rec (car expr))))))
- )
- X
- (defun math-parse-schedule (sched)
- X (mapcar (function
- X (lambda (s)
- X (if (integerp s)
- X s
- X (if (math-vectorp s)
- X (math-parse-schedule (cdr s))
- X (if (eq (car-safe s) 'var)
- X (math-var-to-calcFunc s)
- X (error "Improper component in rewrite schedule"))))))
- X sched)
- )
- X
- (defun math-rwcomp-match-vars (expr)
- X (if (Math-primp expr)
- X (if (eq (car-safe expr) 'var)
- X (let ((entry (assq (nth 2 expr) math-regs)))
- X (if entry
- X (math-rwcomp-register-expr (nth 1 entry))
- X expr))
- X expr)
- X (if (and (eq (car expr) 'calcFunc-quote)
- X (= (length expr) 2))
- X (math-rwcomp-match-vars (nth 1 expr))
- X (if (and (eq (car expr) 'calcFunc-plain)
- X (= (length expr) 2)
- X (not (Math-primp (nth 1 expr))))
- X (list (car expr)
- X (cons (car (nth 1 expr))
- X (mapcar 'math-rwcomp-match-vars (cdr (nth 1 expr)))))
- X (cons (car expr)
- X (mapcar 'math-rwcomp-match-vars (cdr expr))))))
- )
- X
- (defun math-rwcomp-register-expr (num)
- X (let ((entry (nth (1- (- math-num-regs num)) math-regs)))
- X (if (nth 2 entry)
- X (list 'neg (list 'calcFunc-register (nth 1 entry)))
- X (list 'calcFunc-register (nth 1 entry))))
- )
- X
- (defun math-rwcomp-substitute (expr old new)
- X (if (and (eq (car-safe old) 'var)
- X (memq (car-safe new) '(var calcFunc-lambda)))
- X (let ((old-func (math-var-to-calcFunc old))
- X (new-func (math-var-to-calcFunc new)))
- X (math-rwcomp-subst-rec expr))
- X (let ((old-func nil))
- X (math-rwcomp-subst-rec expr)))
- )
- X
- (defun math-rwcomp-subst-rec (expr)
- X (cond ((equal expr old) new)
- X ((Math-primp expr) expr)
- X (t (if (eq (car expr) old-func)
- X (math-build-call new-func (mapcar 'math-rwcomp-subst-rec
- X (cdr expr)))
- X (cons (car expr)
- X (mapcar 'math-rwcomp-subst-rec (cdr expr))))))
- )
- X
- (setq math-rwcomp-tracing nil)
- X
- (defun math-rwcomp-trace (instr)
- X (if math-rwcomp-tracing (progn (terpri) (princ instr)))
- X instr
- )
- X
- (defun math-rwcomp-instr (&rest instr)
- X (setcdr math-prog-last
- X (setq math-prog-last (list (math-rwcomp-trace instr))))
- )
- X
- (defun math-rwcomp-multi-instr (tail &rest instr)
- X (setcdr math-prog-last
- X (setq math-prog-last (list (math-rwcomp-trace (append instr tail)))))
- )
- X
- (defun math-rwcomp-bind-var (reg var)
- X (setcar (math-rwcomp-reg-entry reg) (nth 2 var))
- X (setq math-bound-vars (cons (nth 2 var) math-bound-vars))
- X (math-rwcomp-do-conditions)
- )
- X
- (defun math-rwcomp-unbind-vars (mark)
- X (while (not (eq math-bound-vars mark))
- X (setcar (assq (car math-bound-vars) math-regs) nil)
- X (setq math-bound-vars (cdr math-bound-vars)))
- )
- X
- (defun math-rwcomp-do-conditions ()
- X (let ((cond math-conds))
- X (while cond
- X (if (math-rwcomp-all-regs-done (car cond))
- X (let ((expr (car cond)))
- X (setq math-conds (delq (car cond) math-conds))
- X (setcar cond 1)
- X (math-rwcomp-cond-instr expr)))
- X (setq cond (cdr cond))))
- )
- X
- (defun math-rwcomp-cond-instr (expr)
- X (let (op arg)
- X (cond ((and (eq (car-safe expr) 'calcFunc-matches)
- X (= (length expr) 3)
- X (eq (car-safe (setq arg (math-rwcomp-match-vars (nth 1 expr))))
- X 'calcFunc-register))
- X (math-rwcomp-pattern (nth 2 expr) (nth 1 arg)))
- X ((math-numberp (setq expr (math-rwcomp-match-vars expr)))
- X (if (Math-zerop expr)
- X (math-rwcomp-instr 'backtrack)))
- X ((and (eq (car expr) 'calcFunc-let)
- X (= (length expr) 3))
- X (let ((reg (math-rwcomp-reg)))
- X (math-rwcomp-instr 'let reg (nth 2 expr))
- X (math-rwcomp-pattern (nth 1 expr) reg)))
- X ((and (eq (car expr) 'calcFunc-let)
- X (= (length expr) 2)
- X (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
- X (= (length (nth 1 expr)) 3))
- X (let ((reg (math-rwcomp-reg)))
- X (math-rwcomp-instr 'let reg (nth 2 (nth 1 expr)))
- X (math-rwcomp-pattern (nth 1 (nth 1 expr)) reg)))
- X ((and (setq op (cdr (assq (car-safe expr)
- X '( (calcFunc-integer . integer)
- X (calcFunc-real . real)
- X (calcFunc-constant . constant)
- X (calcFunc-negative . negative) ))))
- X (= (length expr) 2)
- X (or (and (eq (car-safe (nth 1 expr)) 'neg)
- X (memq op '(integer real constant))
- X (setq arg (nth 1 (nth 1 expr))))
- X (setq arg (nth 1 expr)))
- X (eq (car-safe (setq arg (nth 1 expr))) 'calcFunc-register))
- X (math-rwcomp-instr op (nth 1 arg)))
- X ((and (assq (car-safe expr) calc-tweak-eqn-table)
- X (= (length expr) 3)
- X (eq (car-safe (nth 1 expr)) 'calcFunc-register))
- X (if (math-constp (nth 2 expr))
- X (let ((reg (math-rwcomp-reg)))
- X (setcar (nthcdr 3 (car math-regs)) (nth 2 expr))
- X (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
- X (car expr) reg))
- X (if (eq (car (nth 2 expr)) 'calcFunc-register)
- X (math-rwcomp-instr 'rel (nth 1 (nth 1 expr))
- X (car expr) (nth 1 (nth 2 expr)))
- X (math-rwcomp-instr 'cond expr))))
- X ((and (eq (car-safe expr) 'calcFunc-eq)
- X (= (length expr) 3)
- X (eq (car-safe (nth 1 expr)) '%)
- X (eq (car-safe (nth 1 (nth 1 expr))) 'calcFunc-register)
- X (math-constp (nth 2 (nth 1 expr)))
- X (math-constp (nth 2 expr)))
- X (math-rwcomp-instr 'mod (nth 1 (nth 1 (nth 1 expr)))
- X (nth 2 (nth 1 expr)) (nth 2 expr)))
- X ((equal expr '(var remember var-remember))
- X (setq math-remembering 1))
- X ((and (eq (car-safe expr) 'calcFunc-remember)
- X (= (length expr) 2))
- X (setq math-remembering (if math-remembering
- X (list 'calcFunc-lor
- X math-remembering (nth 1 expr))
- X (nth 1 expr))))
- X (t (math-rwcomp-instr 'cond expr))))
- )
- X
- (defun math-rwcomp-same-instr (reg1 reg2 neg)
- X (math-rwcomp-instr (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
- X (nth 2 (math-rwcomp-reg-entry reg2)))
- X neg)
- X 'same-neg
- X 'same)
- X reg1 reg2)
- )
- X
- (defun math-rwcomp-copy-instr (reg1 reg2 neg)
- X (if (eq (eq (nth 2 (math-rwcomp-reg-entry reg1))
- X (nth 2 (math-rwcomp-reg-entry reg2)))
- X neg)
- X (math-rwcomp-instr 'copy-neg reg1 reg2)
- X (or (eq reg1 reg2)
- X (math-rwcomp-instr 'copy reg1 reg2)))
- )
- X
- (defun math-rwcomp-reg ()
- X (prog1
- X math-num-regs
- X (setq math-regs (cons (list nil math-num-regs nil 0) math-regs)
- X math-num-regs (1+ math-num-regs)))
- )
- X
- (defun math-rwcomp-reg-entry (num)
- X (nth (1- (- math-num-regs num)) math-regs)
- )
- X
- X
- (defun math-rwcomp-pattern (expr part &optional not-direct)
- X (cond ((or (math-rwcomp-no-vars expr)
- X (and (eq (car expr) 'calcFunc-quote)
- X (= (length expr) 2)
- X (setq expr (nth 1 expr))))
- X (if (eq (car-safe expr) 'calcFunc-register)
- X (math-rwcomp-same-instr part (nth 1 expr) nil)
- X (let ((reg (math-rwcomp-reg)))
- X (setcar (nthcdr 3 (car math-regs)) expr)
- X (math-rwcomp-same-instr part reg nil))))
- X ((eq (car expr) 'var)
- X (let ((entry (assq (nth 2 expr) math-regs)))
- X (if entry
- X (math-rwcomp-same-instr part (nth 1 entry) nil)
- X (if not-direct
- X (let ((reg (math-rwcomp-reg)))
- X (math-rwcomp-pattern expr reg)
- X (math-rwcomp-copy-instr part reg nil))
- X (if (setq entry (assq (nth 2 expr) math-aliased-vars))
- X (progn
- X (setcar (math-rwcomp-reg-entry (nth 1 entry))
- X (nth 2 expr))
- X (setcar entry nil)
- X (math-rwcomp-copy-instr part (nth 1 entry) nil))
- X (math-rwcomp-bind-var part expr))))))
- X ((and (eq (car expr) 'calcFunc-select)
- X (= (length expr) 2))
- X (let ((reg (math-rwcomp-reg)))
- X (math-rwcomp-instr 'select part reg)
- X (math-rwcomp-pattern (nth 1 expr) reg)))
- X ((and (eq (car expr) 'calcFunc-opt)
- X (memq (length expr) '(2 3)))
- X (error "opt( ) occurs in context where it is not allowed"))
- X ((eq (car expr) 'neg)
- X (if (eq (car (nth 1 expr)) 'var)
- X (let ((entry (assq (nth 2 (nth 1 expr)) math-regs)))
- X (if entry
- X (math-rwcomp-same-instr part (nth 1 entry) t)
- X (if math-copy-neg
- X (let ((reg (math-rwcomp-best-reg (nth 1 expr))))
- X (math-rwcomp-copy-instr part reg t)
- X (math-rwcomp-pattern (nth 1 expr) reg))
- X (setcar (cdr (cdr (math-rwcomp-reg-entry part))) t)
- X (math-rwcomp-pattern (nth 1 expr) part))))
- X (if (math-rwcomp-is-algebraic (nth 1 expr))
- X (math-rwcomp-cond-instr (list 'calcFunc-eq
- X (math-rwcomp-register-expr part)
- X expr))
- X (let ((reg (math-rwcomp-reg)))
- X (math-rwcomp-instr 'func part 'neg reg)
- X (math-rwcomp-pattern (nth 1 expr) reg)))))
- X ((and (eq (car expr) 'calcFunc-apply)
- X (= (length expr) 3))
- X (let ((reg1 (math-rwcomp-reg))
- X (reg2 (math-rwcomp-reg)))
- X (math-rwcomp-instr 'apply part reg1 reg2)
- X (math-rwcomp-pattern (nth 1 expr) reg1)
- X (math-rwcomp-pattern (nth 2 expr) reg2)))
- X ((and (eq (car expr) 'calcFunc-cons)
- X (= (length expr) 3))
- X (let ((reg1 (math-rwcomp-reg))
- X (reg2 (math-rwcomp-reg)))
- X (math-rwcomp-instr 'cons part reg1 reg2)
- X (math-rwcomp-pattern (nth 1 expr) reg1)
- X (math-rwcomp-pattern (nth 2 expr) reg2)))
- X ((and (eq (car expr) 'calcFunc-rcons)
- X (= (length expr) 3))
- X (let ((reg1 (math-rwcomp-reg))
- X (reg2 (math-rwcomp-reg)))
- X (math-rwcomp-instr 'rcons part reg1 reg2)
- X (math-rwcomp-pattern (nth 1 expr) reg1)
- X (math-rwcomp-pattern (nth 2 expr) reg2)))
- X ((and (eq (car expr) 'calcFunc-condition)
- X (>= (length expr) 3))
- X (math-rwcomp-pattern (nth 1 expr) part)
- X (setq expr (cdr expr))
- X (while (setq expr (cdr expr))
- X (let ((cond (math-flatten-lands (car expr))))
- X (while cond
- X (if (math-rwcomp-all-regs-done (car cond))
- X (math-rwcomp-cond-instr (car cond))
- X (setq math-conds (cons (car cond) math-conds)))
- X (setq cond (cdr cond))))))
- X ((and (eq (car expr) 'calcFunc-pand)
- X (= (length expr) 3))
- X (math-rwcomp-pattern (nth 1 expr) part)
- X (math-rwcomp-pattern (nth 2 expr) part))
- X ((and (eq (car expr) 'calcFunc-por)
- X (= (length expr) 3))
- X (math-rwcomp-instr 'alt nil nil [nil nil 4])
- X (let ((math-conds nil)
- X (head math-prog-last)
- X (mark math-bound-vars)
- X (math-copy-neg t))
- X (math-rwcomp-pattern (nth 1 expr) part t)
- X (let ((amark math-aliased-vars)
- X (math-aliased-vars math-aliased-vars)
- X (tail math-prog-last)
- X (p math-bound-vars)
- X entry)
- X (while (not (eq p mark))
- X (setq entry (assq (car p) math-regs)
- X math-aliased-vars (cons (list (car p) (nth 1 entry) nil)
- X math-aliased-vars)
- X p (cdr p))
- X (setcar (math-rwcomp-reg-entry (nth 1 entry)) nil))
- X (setcar (cdr (car head)) (cdr head))
- X (setcdr head nil)
- X (setq math-prog-last head)
- X (math-rwcomp-pattern (nth 2 expr) part)
- X (math-rwcomp-instr 'same 0 0)
- X (setcdr tail math-prog-last)
- X (setq p math-aliased-vars)
- X (while (not (eq p amark))
- X (if (car (car p))
- X (setcar (math-rwcomp-reg-entry (nth 1 (car p)))
- X (car (car p))))
- X (setq p (cdr p)))))
- X (math-rwcomp-do-conditions))
- X ((and (eq (car expr) 'calcFunc-pnot)
- X (= (length expr) 2))
- X (math-rwcomp-instr 'alt nil nil [nil nil 4])
- X (let ((head math-prog-last)
- X (mark math-bound-vars))
- X (math-rwcomp-pattern (nth 1 expr) part)
- X (math-rwcomp-unbind-vars mark)
- X (math-rwcomp-instr 'end-alt head)
- X (math-rwcomp-instr 'backtrack)
- X (setcar (cdr (car head)) (cdr head))
- X (setcdr head nil)
- X (setq math-prog-last head)))
- X (t (let ((props (get (car expr) 'math-rewrite-props)))
- X (if (and (eq (car expr) 'calcFunc-plain)
- X (= (length expr) 2)
- X (not (math-primp (nth 1 expr))))
- X (setq expr (nth 1 expr))) ; but "props" is still nil
- X (if (and (memq 'algebraic props)
- X (math-rwcomp-is-algebraic expr))
- X (math-rwcomp-cond-instr (list 'calcFunc-eq
- X (math-rwcomp-register-expr part)
- X expr))
- X (if (and (memq 'commut props)
- X (= (length expr) 3))
- X (let ((arg1 (nth 1 expr))
- X (arg2 (nth 2 expr))
- X try1 def code head (flip nil))
- X (if (eq (car expr) '-)
- X (setq arg2 (math-rwcomp-neg arg2)))
- X (setq arg1 (cons arg1 (math-rwcomp-best-reg arg1))
- X arg2 (cons arg2 (math-rwcomp-best-reg arg2)))
- X (or (math-rwcomp-order arg1 arg2)
- X (setq def arg1 arg1 arg2 arg2 def flip t))
- X (if (math-rwcomp-optional-arg (car expr) arg1)
- X (error "Too many opt( ) arguments in this context"))
- X (setq def (math-rwcomp-optional-arg (car expr) arg2)
- X head (if (memq (car expr) '(+ -))
- X '(+ -)
- X (if (eq (car expr) '*)
- X '(* /)
- X (list (car expr))))
- X code (if (math-rwcomp-is-constrained
- X (car arg1) head)
- X (if (math-rwcomp-is-constrained
- X (car arg2) head)
- X 0 1)
- X 2))
- X (math-rwcomp-multi-instr (and def (list def))
- X 'try part head
- X (vector nil nil nil code flip)
- X (cdr arg1))
- X (setq try1 (car math-prog-last))
- X (math-rwcomp-pattern (car arg1) (cdr arg1))
- X (math-rwcomp-instr 'try2 try1 (cdr arg2))
- X (if (and (= part 0) (not def) (not math-rewrite-whole)
- X (setq def (get (car expr)
- X 'math-rewrite-default)))
- X (let ((reg1 (math-rwcomp-reg))
- X (reg2 (math-rwcomp-reg)))
- X (if (= (aref (nth 3 try1) 3) 0)
- X (aset (nth 3 try1) 3 1))
- X (math-rwcomp-instr 'try (cdr arg2)
- X (if (equal head '(* /))
- X '(*) head)
- X (vector nil nil nil
- X (if (= code 0)
- X 1 2)
- X nil)
- X reg1 def)
- X (setq try1 (car math-prog-last))
- X (math-rwcomp-pattern (car arg2) reg1)
- X (math-rwcomp-instr 'try2 try1 reg2)
- X (setq math-rhs (list (if (eq (car expr) '-)
- X '+ (car expr))
- X math-rhs
- X (list 'calcFunc-register
- X reg2))))
- X (math-rwcomp-pattern (car arg2) (cdr arg2))))
- X (let* ((args (mapcar (function
- X (lambda (x)
- X (cons x (math-rwcomp-best-reg x))))
- X (cdr expr)))
- X (args2 (copy-sequence args))
- X (argp (reverse args2))
- X (defs nil)
- X (num 1))
- X (while argp
- X (let ((def (math-rwcomp-optional-arg (car expr)
- X (car argp))))
- X (if def
- X (progn
- X (setq args2 (delq (car argp) args2)
- X defs (cons (cons def (cdr (car argp)))
- X defs))
- X (math-rwcomp-multi-instr
- X (mapcar 'cdr args2)
- X (if (or (and (memq 'unary1 props)
- X (= (length args2) 1)
- X (eq (car args2) (car args)))
- X (and (memq 'unary2 props)
- X (= (length args) 2)
- X (eq (car args2) (nth 1 args))))
- X 'func-opt
- X 'func-def)
- X part (car expr)
- X defs))))
- X (setq argp (cdr argp)))
- X (math-rwcomp-multi-instr (mapcar 'cdr args)
- X 'func part (car expr))
- X (setq args (sort args 'math-rwcomp-order))
- X (while args
- X (math-rwcomp-pattern (car (car args)) (cdr (car args)))
- X (setq num (1+ num)
- X args (cdr args)))))))))
- )
- X
- (defun math-rwcomp-best-reg (x)
- X (or (and (eq (car-safe x) 'var)
- X (let ((entry (assq (nth 2 x) math-aliased-vars)))
- X (and entry
- X (not (nth 2 entry))
- X (not (nth 2 (math-rwcomp-reg-entry (nth 1 entry))))
- X (progn
- X (setcar (cdr (cdr entry)) t)
- X (nth 1 entry)))))
- X (math-rwcomp-reg))
- )
- X
- (defun math-rwcomp-all-regs-done (expr)
- X (if (Math-primp expr)
- X (or (not (eq (car-safe expr) 'var))
- X (assq (nth 2 expr) math-regs)
- X (eq (nth 2 expr) 'var-remember)
- X (math-const-var expr))
- X (if (and (eq (car expr) 'calcFunc-let)
- X (= (length expr) 3))
- X (math-rwcomp-all-regs-done (nth 2 expr))
- X (if (and (eq (car expr) 'calcFunc-let)
- X (= (length expr) 2)
- X (eq (car-safe (nth 1 expr)) 'calcFunc-assign)
- X (= (length (nth 1 expr)) 3))
- X (math-rwcomp-all-regs-done (nth 2 (nth 1 expr)))
- X (while (and (setq expr (cdr expr))
- X (math-rwcomp-all-regs-done (car expr))))
- X (null expr))))
- )
- X
- (defun math-rwcomp-no-vars (expr)
- X (if (Math-primp expr)
- X (or (not (eq (car-safe expr) 'var))
- X (math-const-var expr))
- X (and (not (memq (car expr) '(calcFunc-condition
- X calcFunc-select calcFunc-quote
- X calcFunc-plain calcFunc-opt
- X calcFunc-por calcFunc-pand
- X calcFunc-pnot calcFunc-apply
- X calcFunc-cons calcFunc-rcons)))
- X (progn
- X (while (and (setq expr (cdr expr))
- X (math-rwcomp-no-vars (car expr))))
- X (null expr))))
- )
- X
- (defun math-rwcomp-is-algebraic (expr)
- X (if (Math-primp expr)
- X (or (not (eq (car-safe expr) 'var))
- X (math-const-var expr)
- X (assq (nth 2 expr) math-regs))
- X (and (memq 'algebraic (get (car expr) 'math-rewrite-props))
- X (progn
- X (while (and (setq expr (cdr expr))
- X (math-rwcomp-is-algebraic (car expr))))
- X (null expr))))
- )
- X
- (defun math-rwcomp-is-constrained (expr not-these)
- X (if (Math-primp expr)
- X (not (eq (car-safe expr) 'var))
- X (if (eq (car expr) 'calcFunc-plain)
- X (math-rwcomp-is-constrained (nth 1 expr) not-these)
- X (not (or (memq (car expr) '(neg calcFunc-select))
- X (memq (car expr) not-these)
- X (and (memq 'commut (get (car expr) 'math-rewrite-props))
- X (or (eq (car-safe (nth 1 expr)) 'calcFunc-opt)
- X (eq (car-safe (nth 2 expr)) 'calcFunc-opt)))))))
- )
- X
- (defun math-rwcomp-optional-arg (head argp)
- X (let ((arg (car argp)))
- X (if (eq (car-safe arg) 'calcFunc-opt)
- X (and (memq (length arg) '(2 3))
- X (progn
- X (or (eq (car-safe (nth 1 arg)) 'var)
- X (error "First argument of opt( ) must be a variable"))
- X (setcar argp (nth 1 arg))
- X (if (= (length arg) 2)
- X (or (get head 'math-rewrite-default)
- X (error "opt( ) must include a default in this context"))
- X (nth 2 arg))))
- X (and (eq (car-safe arg) 'neg)
- X (let* ((part (list (nth 1 arg)))
- X (partp (math-rwcomp-optional-arg head part)))
- X (and partp
- X (setcar argp (math-rwcomp-neg (car part)))
- X (math-neg partp))))))
- )
- X
- (defun math-rwcomp-neg (expr)
- X (if (memq (car-safe expr) '(* /))
- X (if (eq (car-safe (nth 1 expr)) 'var)
- X (list (car expr) (list 'neg (nth 1 expr)) (nth 2 expr))
- X (if (eq (car-safe (nth 2 expr)) 'var)
- X (list (car expr) (nth 1 expr) (list 'neg (nth 2 expr)))
- X (math-neg expr)))
- X (math-neg expr))
- )
- X
- (defun math-rwcomp-assoc-args (expr)
- X (if (and (eq (car-safe (nth 1 expr)) (car expr))
- X (= (length (nth 1 expr)) 3))
- X (math-rwcomp-assoc-args (nth 1 expr))
- X (setq math-args (cons (nth 1 expr) math-args)))
- X (if (and (eq (car-safe (nth 2 expr)) (car expr))
- X (= (length (nth 2 expr)) 3))
- X (math-rwcomp-assoc-args (nth 2 expr))
- X (setq math-args (cons (nth 2 expr) math-args)))
- )
- X
- (defun math-rwcomp-addsub-args (expr)
- X (if (memq (car-safe (nth 1 expr)) '(+ -))
- X (math-rwcomp-addsub-args (nth 1 expr))
- X (setq math-args (cons (nth 1 expr) math-args)))
- X (if (eq (car expr) '-)
- X (setq math-args (cons (math-rwcomp-neg (nth 2 expr)) math-args))
- X (if (eq (car-safe (nth 2 expr)) '+)
- X (math-rwcomp-addsub-args (nth 2 expr))
- X (setq math-args (cons (nth 2 expr) math-args))))
- )
- X
- (defun math-rwcomp-order (a b)
- X (< (math-rwcomp-priority (car a))
- X (math-rwcomp-priority (car b)))
- )
- X
- ;;; Order of priority: 0 Constants and other exact matches (first)
- ;;; 10 Functions (except below)
- ;;; 20 Meta-variables which occur more than once
- ;;; 30 Algebraic functions
- ;;; 40 Commutative/associative functions
- ;;; 50 Meta-variables which occur only once
- ;;; +100 for every "!!!" (pnot) in the pattern
- ;;; 10000 Optional arguments (last)
- X
- (defun math-rwcomp-priority (expr)
- X (+ (math-rwcomp-count-pnots expr)
- X (cond ((eq (car-safe expr) 'calcFunc-opt)
- X 10000)
- X ((math-rwcomp-no-vars expr)
- X 0)
- X ((eq (car expr) 'calcFunc-quote)
- X 0)
- X ((eq (car expr) 'var)
- X (if (assq (nth 2 expr) math-regs)
- X 0
- X (if (= (math-rwcomp-count-refs expr) 1)
- X 50
- X 20)))
- X (t (let ((props (get (car expr) 'math-rewrite-props)))
- X (if (or (memq 'commut props)
- X (memq 'assoc props))
- X 40
- X (if (memq 'algebraic props)
- X 30
- X 10))))))
- )
- X
- (defun math-rwcomp-count-refs (var)
- X (let ((count (or (math-expr-contains-count math-pattern var) 0))
- X (p math-conds))
- X (while p
- X (if (eq (car-safe (car p)) 'calcFunc-let)
- X (if (= (length (car p)) 3)
- X (setq count (+ count
- X (or (math-expr-contains-count (nth 2 (car p)) var)
- X 0)))
- X (if (and (= (length (car p)) 2)
- X (eq (car-safe (nth 1 (car p))) 'calcFunc-assign)
- X (= (length (nth 1 (car p))) 3))
- X (setq count (+ count
- X (or (math-expr-contains-count
- X (nth 2 (nth 1 (car p))) var) 0))))))
- X (setq p (cdr p)))
- X count)
- )
- X
- (defun math-rwcomp-count-pnots (expr)
- X (if (Math-primp expr)
- X 0
- X (if (eq (car expr) 'calcFunc-pnot)
- X 100
- X (let ((count 0))
- X (while (setq expr (cdr expr))
- X (setq count (+ count (math-rwcomp-count-pnots (car expr)))))
- X count)))
- )
- X
- ;;; In the current implementation, all associative functions must
- ;;; also be commutative.
- X
- (put '+ 'math-rewrite-props '(algebraic assoc commut))
- (put '- 'math-rewrite-props '(algebraic assoc commut)) ; see below
- (put '* 'math-rewrite-props '(algebraic assoc commut)) ; see below
- (put '/ 'math-rewrite-props '(algebraic unary1))
- (put '^ 'math-rewrite-props '(algebraic unary1))
- (put '% 'math-rewrite-props '(algebraic))
- (put 'neg 'math-rewrite-props '(algebraic))
- (put 'calcFunc-idiv 'math-rewrite-props '(algebraic))
- (put 'calcFunc-abs 'math-rewrite-props '(algebraic))
- (put 'calcFunc-sign 'math-rewrite-props '(algebraic))
- (put 'calcFunc-round 'math-rewrite-props '(algebraic))
- (put 'calcFunc-rounde 'math-rewrite-props '(algebraic))
- (put 'calcFunc-roundu 'math-rewrite-props '(algebraic))
- (put 'calcFunc-trunc 'math-rewrite-props '(algebraic))
- (put 'calcFunc-floor 'math-rewrite-props '(algebraic))
- (put 'calcFunc-ceil 'math-rewrite-props '(algebraic))
- (put 'calcFunc-re 'math-rewrite-props '(algebraic))
- (put 'calcFunc-im 'math-rewrite-props '(algebraic))
- (put 'calcFunc-conj 'math-rewrite-props '(algebraic))
- (put 'calcFunc-arg 'math-rewrite-props '(algebraic))
- (put 'calcFunc-and 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-or 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-xor 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-eq 'math-rewrite-props '(commut))
- (put 'calcFunc-neq 'math-rewrite-props '(commut))
- (put 'calcFunc-land 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-lor 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-beta 'math-rewrite-props '(commut))
- (put 'calcFunc-gcd 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-lcm 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-max 'math-rewrite-props '(algebraic assoc commut))
- (put 'calcFunc-min 'math-rewrite-props '(algebraic assoc commut))
- (put 'calcFunc-vunion 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-vint 'math-rewrite-props '(assoc commut))
- (put 'calcFunc-vxor 'math-rewrite-props '(assoc commut))
- X
- ;;; Note: "*" is not commutative for matrix args, but we pretend it is.
- ;;; Also, "-" is not commutative but the code tweaks things so that it is.
- X
- (put '+ 'math-rewrite-default 0)
- (put '- 'math-rewrite-default 0)
- (put '* 'math-rewrite-default 1)
- (put '/ 'math-rewrite-default 1)
- (put '^ 'math-rewrite-default 1)
- (put 'calcFunc-land 'math-rewrite-default 1)
- (put 'calcFunc-lor 'math-rewrite-default 0)
- (put 'calcFunc-vunion 'math-rewrite-default '(vec))
- (put 'calcFunc-vint 'math-rewrite-default '(vec))
- (put 'calcFunc-vdiff 'math-rewrite-default '(vec))
- (put 'calcFunc-vxor 'math-rewrite-default '(vec))
- X
- (defmacro math-rwfail (&optional back)
- X (list 'setq 'pc
- X (list 'and
- X (if back
- X '(setq btrack (cdr btrack))
- X 'btrack)
- X ''((backtrack))))
- )
- X
- ;;; This monstrosity is necessary because the use of static vectors of
- ;;; registers makes rewrite rules non-reentrant. Yucko!
- (defmacro math-rweval (form)
- X (list 'let '((orig (car rules)))
- X '(setcar rules (quote (nil nil nil no-phase)))
- X (list 'unwind-protect
- X form
- X '(setcar rules orig)))
- )
- X
- (setq math-rewrite-phase 1)
- X
- (defun math-apply-rewrites (expr rules &optional heads ruleset)
- X (and
- X (setq rules (cdr (or (assq (car-safe expr) rules)
- X (assq nil rules))))
- X (let ((result nil)
- X op regs inst part pc mark btrack
- X (tracing math-rwcomp-tracing)
- X (phase math-rewrite-phase))
- X (while rules
- X (or
- X (and (setq part (nth 2 (car rules)))
- X heads
- X (not (memq part heads)))
- X (and (setq part (nth 3 (car rules)))
- X (not (memq phase part)))
- X (progn
- X (setq regs (car (car rules))
- X pc (nth 1 (car rules))
- X btrack nil)
- X (aset regs 0 expr)
- X (while pc
- X
- X (and tracing
- X (progn (terpri) (princ (car pc))
- X (if (and (natnump (nth 1 (car pc)))
- X (< (nth 1 (car pc)) (length regs)))
- X (princ (format "\n part = %s"
- X (aref regs (nth 1 (car pc))))))))
- X
- X (cond ((eq (setq op (car (setq inst (car pc)))) 'func)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (eq (car part)
- X (car (setq inst (cdr (cdr inst)))))
- X (progn
- X (while (and (setq inst (cdr inst)
- X part (cdr part))
- X inst)
- X (aset regs (car inst) (car part)))
- X (not (or inst part))))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((eq op 'same)
- X (if (or (equal (setq part (aref regs (nth 1 inst)))
- X (setq mark (aref regs (nth 2 inst))))
- X (Math-equal part mark))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((and (eq op 'try)
- X calc-matrix-mode
- X (not (eq calc-matrix-mode 'scalar))
- X (eq (car (nth 2 inst)) '*)
- X (consp (setq part (aref regs (car (cdr inst)))))
- X (eq (car part) '*)
- X (not (math-known-scalarp part)))
- X (setq mark (nth 3 inst)
- X pc (cdr pc))
- X (if (aref mark 4)
- X (progn
- X (aset regs (nth 4 inst) (nth 2 part))
- X (aset mark 1 (cdr (cdr part))))
- X (aset regs (nth 4 inst) (nth 1 part))
- X (aset mark 1 (cdr part)))
- X (aset mark 0 (cdr part))
- X (aset mark 2 0))
- X
- X ((eq op 'try)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (memq (car part) (nth 2 inst))
- X (= (length part) 3)
- X (or (not (eq (car part) '/))
- X (Math-objectp (nth 2 part))))
- X (progn
- X (setq op nil
- X mark (car (cdr (setq inst (cdr (cdr inst))))))
- X (and
- X (memq 'assoc (get (car part) 'math-rewrite-props))
- X (not (= (aref mark 3) 0))
- X (while (if (and (consp (nth 1 part))
- X (memq (car (nth 1 part)) (car inst)))
- X (setq op (cons (if (eq (car part) '-)
- X (math-rwapply-neg
- X (nth 2 part))
- X (nth 2 part))
- X op)
- X part (nth 1 part))
- X (if (and (consp (nth 2 part))
- X (memq (car (nth 2 part))
- X (car inst))
- X (not (eq (car (nth 2 part)) '-)))
- X (setq op (cons (nth 1 part) op)
- X part (nth 2 part))))))
- X (setq op (cons (nth 1 part)
- X (cons (if (eq (car part) '-)
- X (math-rwapply-neg
- X (nth 2 part))
- X (if (eq (car part) '/)
- X (math-rwapply-inv
- X (nth 2 part))
- X (nth 2 part)))
- X op))
- X btrack (cons pc btrack)
- X pc (cdr pc))
- X (aset regs (nth 2 inst) (car op))
- X (aset mark 0 op)
- X (aset mark 1 op)
- X (aset mark 2 (if (cdr (cdr op)) 1 0)))
- X (if (nth 5 inst)
- X (if (and (consp part)
- X (eq (car part) 'neg)
- X (eq (car (nth 2 inst)) '*)
- X (eq (nth 5 inst) 1))
- X (progn
- X (setq mark (nth 3 inst)
- X pc (cdr pc))
- X (aset regs (nth 4 inst) (nth 1 part))
- X (aset mark 1 -1)
- X (aset mark 2 4))
- X (setq mark (nth 3 inst)
- X pc (cdr pc))
- X (aset regs (nth 4 inst) part)
- X (aset mark 2 3))
- X (math-rwfail))))
- X
- X ((eq op 'try2)
- X (setq part (nth 1 inst) ; try instr
- X mark (nth 3 part)
- X op (aref mark 2)
- X pc (cdr pc))
- X (aset regs (nth 2 inst)
- X (cond
- X ((eq op 0)
- X (if (eq (aref mark 0) (aref mark 1))
- X (nth 1 (aref mark 0))
- X (car (aref mark 0))))
- X ((eq op 1)
- X (setq mark (delq (car (aref mark 1))
- X (copy-sequence (aref mark 0)))
- X op (car (nth 2 part)))
- X (if (eq op '*)
- X (progn
- X (setq mark (nreverse mark)
- X part (list '* (nth 1 mark) (car mark))
- X mark (cdr mark))
- X (while (setq mark (cdr mark))
- X (setq part (list '* (car mark) part))))
- X (setq part (car mark)
- X mark (cdr mark)
- X part (if (and (eq op '+)
- X (consp (car mark))
- X (eq (car (car mark)) 'neg))
- X (list '- part
- X (nth 1 (car mark)))
- X (list op part (car mark))))
- X (while (setq mark (cdr mark))
- X (setq part (if (and (eq op '+)
- X (consp (car mark))
- X (eq (car (car mark)) 'neg))
- X (list '- part
- X (nth 1 (car mark)))
- X (list op part (car mark))))))
- X part)
- X ((eq op 2)
- X (car (aref mark 1)))
- X ((eq op 3) (nth 5 part))
- X (t (aref mark 1)))))
- X
- X ((eq op 'select)
- X (setq pc (cdr pc))
- X (if (and (consp (setq part (aref regs (nth 1 inst))))
- X (eq (car part) 'calcFunc-select))
- X (aset regs (nth 2 inst) (nth 1 part))
- X (if math-rewrite-selections
- X (math-rwfail)
- X (aset regs (nth 2 inst) part))))
- X
- X ((eq op 'same-neg)
- X (if (or (equal (setq part (aref regs (nth 1 inst)))
- X (setq mark (math-neg
- X (aref regs (nth 2 inst)))))
- X (Math-equal part mark))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((eq op 'backtrack)
- X (setq inst (car (car btrack)) ; "try" or "alt" instr
- X pc (cdr (car btrack))
- X mark (or (nth 3 inst) [nil nil 4])
- X op (aref mark 2))
- X (cond ((eq op 0)
- X (if (setq op (cdr (aref mark 1)))
- X (aset regs (nth 4 inst) (car (aset mark 1 op)))
- X (if (nth 5 inst)
- X (progn
- X (aset mark 2 3)
- X (aset regs (nth 4 inst)
- X (aref regs (nth 1 inst))))
- X (math-rwfail t))))
- X ((eq op 1)
- X (if (setq op (cdr (aref mark 1)))
- X (aset regs (nth 4 inst) (car (aset mark 1 op)))
- X (if (= (aref mark 3) 1)
- X (if (nth 5 inst)
- X (progn
- X (aset mark 2 3)
- X (aset regs (nth 4 inst)
- X (aref regs (nth 1 inst))))
- X (math-rwfail t))
- X (aset mark 2 2)
- X (aset mark 1 (cons nil (aref mark 0)))
- X (math-rwfail))))
- X ((eq op 2)
- X (if (setq op (cdr (aref mark 1)))
- X (progn
- X (setq mark (delq (car (aset mark 1 op))
- X (copy-sequence
- X (aref mark 0)))
- X op (car (nth 2 inst)))
- X (if (eq op '*)
- X (progn
- X (setq mark (nreverse mark)
- X part (list '* (nth 1 mark)
- X (car mark))
- X mark (cdr mark))
- X (while (setq mark (cdr mark))
- X (setq part (list '* (car mark)
- X part))))
- X (setq part (car mark)
- X mark (cdr mark)
- X part (if (and (eq op '+)
- X (consp (car mark))
- X (eq (car (car mark))
- X 'neg))
- X (list '- part
- X (nth 1 (car mark)))
- X (list op part (car mark))))
- X (while (setq mark (cdr mark))
- X (setq part (if (and (eq op '+)
- X (consp (car mark))
- X (eq (car (car mark))
- X 'neg))
- X (list '- part
- X (nth 1 (car mark)))
- X (list op part (car mark))))))
- X (aset regs (nth 4 inst) part))
- X (if (nth 5 inst)
- X (progn
- X (aset mark 2 3)
- X (aset regs (nth 4 inst)
- X (aref regs (nth 1 inst))))
- X (math-rwfail t))))
- X ((eq op 4)
- X (setq btrack (cdr btrack)))
- X (t (math-rwfail t))))
- X
- X ((eq op 'integer)
- X (if (Math-integerp (setq part (aref regs (nth 1 inst))))
- X (setq pc (cdr pc))
- X (if (Math-primp part)
- X (math-rwfail)
- X (setq part (math-rweval (math-simplify part)))
- X (if (Math-integerp part)
- X (setq pc (cdr pc))
- X (math-rwfail)))))
- X
- X ((eq op 'real)
- X (if (Math-realp (setq part (aref regs (nth 1 inst))))
- X (setq pc (cdr pc))
- X (if (Math-primp part)
- X (math-rwfail)
- X (setq part (math-rweval (math-simplify part)))
- X (if (Math-realp part)
- X (setq pc (cdr pc))
- X (math-rwfail)))))
- X
- X ((eq op 'constant)
- X (if (math-constp (setq part (aref regs (nth 1 inst))))
- X (setq pc (cdr pc))
- X (if (Math-primp part)
- X (math-rwfail)
- X (setq part (math-rweval (math-simplify part)))
- X (if (math-constp part)
- X (setq pc (cdr pc))
- X (math-rwfail)))))
- X
- X ((eq op 'negative)
- X (if (math-looks-negp (setq part (aref regs (nth 1 inst))))
- X (setq pc (cdr pc))
- X (if (Math-primp part)
- X (math-rwfail)
- X (setq part (math-rweval (math-simplify part)))
- X (if (math-looks-negp part)
- X (setq pc (cdr pc))
- X (math-rwfail)))))
- X
- X ((eq op 'rel)
- X (setq part (math-compare (aref regs (nth 1 inst))
- X (aref regs (nth 3 inst)))
- X op (nth 2 inst))
- X (if (= part 2)
- X (setq part (math-rweval
- X (math-simplify
- X (calcFunc-sign
- X (math-sub (aref regs (nth 1 inst))
- X (aref regs (nth 3 inst))))))))
- X (if (cond ((eq op 'calcFunc-eq)
- X (eq part 0))
- X ((eq op 'calcFunc-neq)
- X (memq part '(-1 1)))
- X ((eq op 'calcFunc-lt)
- X (eq part -1))
- X ((eq op 'calcFunc-leq)
- X (memq part '(-1 0)))
- X ((eq op 'calcFunc-gt)
- X (eq part 1))
- X ((eq op 'calcFunc-geq)
- X (memq part '(0 1))))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((eq op 'func-def)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (eq (car part)
- X (car (setq inst (cdr (cdr inst))))))
- X (progn
- X (setq inst (cdr inst)
- X mark (car inst))
- X (while (and (setq inst (cdr inst)
- X part (cdr part))
- X inst)
- X (aset regs (car inst) (car part)))
- X (if (or inst part)
- X (setq pc (cdr pc))
- X (while (eq (car (car (setq pc (cdr pc))))
- X 'func-def))
- X (setq pc (cdr pc)) ; skip over "func"
- X (while mark
- X (aset regs (cdr (car mark)) (car (car mark)))
- X (setq mark (cdr mark)))))
- X (math-rwfail)))
- X
- X ((eq op 'func-opt)
- X (if (or (not (and (consp
- X (setq part (aref regs (car (cdr inst)))))
- X (eq (car part) (nth 2 inst))))
- X (and (= (length part) 2)
- X (setq part (nth 1 part))))
- X (progn
- X (setq mark (nth 3 inst))
- X (aset regs (nth 4 inst) part)
- X (while (eq (car (car (setq pc (cdr pc)))) 'func-def))
- X (setq pc (cdr pc)) ; skip over "func"
- X (while mark
- X (aset regs (cdr (car mark)) (car (car mark)))
- X (setq mark (cdr mark))))
- X (setq pc (cdr pc))))
- X
- X ((eq op 'mod)
- X (if (if (Math-zerop (setq part (aref regs (nth 1 inst))))
- X (Math-zerop (nth 3 inst))
- X (and (not (Math-zerop (nth 2 inst)))
- X (progn
- X (setq part (math-mod part (nth 2 inst)))
- X (or (Math-numberp part)
- X (setq part (math-rweval
- X (math-simplify part))))
- X (Math-equal part (nth 3 inst)))))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((eq op 'apply)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (not (Math-objvecp part))
- X (not (eq (car part) 'var)))
- X (progn
- X (aset regs (nth 2 inst)
- X (math-calcFunc-to-var (car part)))
- X (aset regs (nth 3 inst)
- X (cons 'vec (cdr part)))
- X (setq pc (cdr pc)))
- X (math-rwfail)))
- X
- X ((eq op 'cons)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (eq (car part) 'vec)
- X (cdr part))
- X (progn
- X (aset regs (nth 2 inst) (nth 1 part))
- X (aset regs (nth 3 inst) (cons 'vec (cdr (cdr part))))
- X (setq pc (cdr pc)))
- X (math-rwfail)))
- X
- X ((eq op 'rcons)
- X (if (and (consp (setq part (aref regs (car (cdr inst)))))
- X (eq (car part) 'vec)
- X (cdr part))
- X (progn
- X (aset regs (nth 2 inst) (calcFunc-rhead part))
- X (aset regs (nth 3 inst) (calcFunc-rtail part))
- X (setq pc (cdr pc)))
- X (math-rwfail)))
- X
- X ((eq op 'cond)
- X (if (math-is-true
- X (math-rweval
- X (math-simplify
- X (math-rwapply-replace-regs (nth 1 inst)))))
- X (setq pc (cdr pc))
- X (math-rwfail)))
- X
- X ((eq op 'let)
- X (aset regs (nth 1 inst)
- X (math-rweval
- X (math-normalize
- X (math-rwapply-replace-regs (nth 2 inst)))))
- X (setq pc (cdr pc)))
- X
- X ((eq op 'copy)
- X (aset regs (nth 2 inst) (aref regs (nth 1 inst)))
- X (setq pc (cdr pc)))
- X
- X ((eq op 'copy-neg)
- X (aset regs (nth 2 inst)
- X (math-rwapply-neg (aref regs (nth 1 inst))))
- X (setq pc (cdr pc)))
- X
- X ((eq op 'alt)
- X (setq btrack (cons pc btrack)
- X pc (nth 1 inst)))
- X
- X ((eq op 'end-alt)
- X (while (and btrack (not (eq (car btrack) (nth 1 inst))))
- X (setq btrack (cdr btrack)))
- X (setq btrack (cdr btrack)
- X pc (cdr pc)))
- X
- X ((eq op 'done)
- X (setq result (math-rwapply-replace-regs (nth 1 inst)))
- X (if (or (and (eq (car-safe result) '+)
- X (eq (nth 2 result) 0))
- X (and (eq (car-safe result) '*)
- X (eq (nth 2 result) 1)))
- X (setq result (nth 1 result)))
- X (setq part (and (nth 2 inst)
- X (math-is-true
- X (math-rweval
- X (math-simplify
- X (math-rwapply-replace-regs
- X (nth 2 inst)))))))
- X (if (or (equal result expr)
- X (equal (setq result (math-normalize result)) expr))
- X (setq result nil)
- X (if part (math-rwapply-remember expr result))
- X (setq rules nil))
- X (setq pc nil))
- X
- X (t (error "%s is not a valid rewrite opcode" op))))))
- X (setq rules (cdr rules)))
- X result))
- )
- X
- (defun math-rwapply-neg (expr)
- X (if (and (consp expr)
- X (memq (car expr) '(* /)))
- X (if (Math-objectp (nth 2 expr))
- X (list (car expr) (nth 1 expr) (math-neg (nth 2 expr)))
- X (list (car expr)
- X (if (Math-objectp (nth 1 expr))
- X (math-neg (nth 1 expr))
- X (list '* -1 (nth 1 expr)))
- X (nth 2 expr)))
- X (math-neg expr))
- )
- X
- (defun math-rwapply-inv (expr)
- X (if (and (Math-integerp expr)
- X calc-prefer-frac)
- X (math-make-frac 1 expr)
- X (list '/ 1 expr))
- )
- X
- (defun math-rwapply-replace-regs (expr)
- X (cond ((Math-primp expr)
- X expr)
- X ((eq (car expr) 'calcFunc-register)
- X (setq expr (aref regs (nth 1 expr)))
- X (if (eq (car-safe expr) '*)
- X (if (eq (nth 1 expr) -1)
- X (math-neg (nth 2 expr))
- X (if (eq (nth 1 expr) 1)
- X (nth 2 expr)
- X expr))
- X expr))
- X ((and (eq (car expr) 'calcFunc-eval)
- X (= (length expr) 2))
- X (calc-with-default-simplification
- X (math-normalize (math-rwapply-replace-regs (nth 1 expr)))))
- X ((and (eq (car expr) 'calcFunc-evalsimp)
- X (= (length expr) 2))
- X (math-simplify (math-rwapply-replace-regs (nth 1 expr))))
- X ((and (eq (car expr) 'calcFunc-evalextsimp)
- X (= (length expr) 2))
- X (math-simplify-extended (math-rwapply-replace-regs (nth 1 expr))))
- X ((and (eq (car expr) 'calcFunc-apply)
- X (= (length expr) 3))
- X (let ((func (math-rwapply-replace-regs (nth 1 expr)))
- X (args (math-rwapply-replace-regs (nth 2 expr)))
- X call)
- X (if (and (math-vectorp args)
- X (not (eq (car-safe (setq call (math-build-call
- X (math-var-to-calcFunc func)
- X (cdr args))))
- X 'calcFunc-call)))
- X call
- X (list 'calcFunc-apply func args))))
- X ((and (eq (car expr) 'calcFunc-cons)
- X (= (length expr) 3))
- X (let ((head (math-rwapply-replace-regs (nth 1 expr)))
- X (tail (math-rwapply-replace-regs (nth 2 expr))))
- X (if (math-vectorp tail)
- X (cons 'vec (cons head (cdr tail)))
- X (list 'calcFunc-cons head tail))))
- X ((and (eq (car expr) 'calcFunc-rcons)
- X (= (length expr) 3))
- X (let ((head (math-rwapply-replace-regs (nth 1 expr)))
- X (tail (math-rwapply-replace-regs (nth 2 expr))))
- X (if (math-vectorp head)
- X (append head (list tail))
- X (list 'calcFunc-rcons head tail))))
- X ((and (eq (car expr) 'neg)
- X (math-rwapply-reg-looks-negp (nth 1 expr)))
- X (math-rwapply-reg-neg (nth 1 expr)))
- X ((and (eq (car expr) 'neg)
- X (eq (car-safe (nth 1 expr)) 'calcFunc-register)
- X (math-scalarp (aref regs (nth 1 (nth 1 expr)))))
- X (math-neg (math-rwapply-replace-regs (nth 1 expr))))
- X ((and (eq (car expr) '+)
- X (math-rwapply-reg-looks-negp (nth 1 expr)))
- X (list '- (math-rwapply-replace-regs (nth 2 expr))
- X (math-rwapply-reg-neg (nth 1 expr))))
- X ((and (eq (car expr) '+)
- X (math-rwapply-reg-looks-negp (nth 2 expr)))
- X (list '- (math-rwapply-replace-regs (nth 1 expr))
- X (math-rwapply-reg-neg (nth 2 expr))))
- X ((and (eq (car expr) '-)
- X (math-rwapply-reg-looks-negp (nth 2 expr)))
- X (list '+ (math-rwapply-replace-regs (nth 1 expr))
- X (math-rwapply-reg-neg (nth 2 expr))))
- X ((eq (car expr) '*)
- X (cond ((eq (nth 1 expr) -1)
- X (if (math-rwapply-reg-looks-negp (nth 2 expr))
- X (math-rwapply-reg-neg (nth 2 expr))
- X (math-neg (math-rwapply-replace-regs (nth 2 expr)))))
- X ((eq (nth 1 expr) 1)
- X (math-rwapply-replace-regs (nth 2 expr)))
- X ((eq (nth 2 expr) -1)
- X (if (math-rwapply-reg-looks-negp (nth 1 expr))
- X (math-rwapply-reg-neg (nth 1 expr))
- X (math-neg (math-rwapply-replace-regs (nth 1 expr)))))
- X ((eq (nth 2 expr) 1)
- X (math-rwapply-replace-regs (nth 1 expr)))
- X (t
- X (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
- X (arg2 (math-rwapply-replace-regs (nth 2 expr))))
- X (cond ((and (eq (car-safe arg1) '/)
- X (eq (nth 1 arg1) 1))
- X (list '/ arg2 (nth 2 arg1)))
- X ((and (eq (car-safe arg2) '/)
- X (eq (nth 1 arg2) 1))
- X (list '/ arg1 (nth 2 arg2)))
- X (t (list '* arg1 arg2)))))))
- X ((eq (car expr) '/)
- X (let ((arg1 (math-rwapply-replace-regs (nth 1 expr)))
- X (arg2 (math-rwapply-replace-regs (nth 2 expr))))
- X (if (eq (car-safe arg2) '/)
- X (list '/ (list '* arg1 (nth 2 arg2)) (nth 1 arg2))
- X (list '/ arg1 arg2))))
- X ((and (eq (car expr) 'calcFunc-plain)
- X (= (length expr) 2))
- X (if (Math-primp (nth 1 expr))
- X (nth 1 expr)
- X (if (eq (car (nth 1 expr)) 'calcFunc-register)
- X (aref regs (nth 1 (nth 1 expr)))
- X (cons (car (nth 1 expr)) (mapcar 'math-rwapply-replace-regs
- X (cdr (nth 1 expr)))))))
- X (t (cons (car expr) (mapcar 'math-rwapply-replace-regs (cdr expr)))))
- )
- X
- (defun math-rwapply-reg-looks-negp (expr)
- X (if (eq (car-safe expr) 'calcFunc-register)
- X (math-looks-negp (aref regs (nth 1 expr)))
- X (if (memq (car-safe expr) '(* /))
- X (or (math-rwapply-reg-looks-negp (nth 1 expr))
- X (math-rwapply-reg-looks-negp (nth 2 expr)))))
- )
- X
- (defun math-rwapply-reg-neg (expr) ; expr must satisfy rwapply-reg-looks-negp
- X (if (eq (car expr) 'calcFunc-register)
- X (math-neg (math-rwapply-replace-regs expr))
- X (if (math-rwapply-reg-looks-negp (nth 1 expr))
- X (math-rwapply-replace-regs (list (car expr)
- X (math-rwapply-reg-neg (nth 1 expr))
- X (nth 2 expr)))
- X (math-rwapply-replace-regs (list (car expr)
- X (nth 1 expr)
- X (math-rwapply-reg-neg (nth 2 expr))))))
- )
- X
- (defun math-rwapply-remember (old new)
- X (let ((varval (symbol-value (nth 2 (car ruleset))))
- X (rules (assq (car-safe old) ruleset)))
- SHAR_EOF
- true || echo 'restore of calc-rewr.el failed'
- fi
- echo 'End of part 25'
- echo 'File calc-rewr.el is continued in part 26'
- echo 26 > _shar_seq_.tmp
- exit 0
- exit 0 # Just in case...
- --
- Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
- Sterling Software, IMD UUCP: uunet!sparky!kent
- Phone: (402) 291-8300 FAX: (402) 291-4362
- Please send comp.sources.misc-related mail to kent@uunet.uu.net.
-